home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / CHARSTR.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  9.0 KB  |  318 lines
  1. ; CHARSTR.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Character and String Operations                *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley        Date: Sep 1985            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;* - 23 Dec 92: Added R^4 support: (string ch1 ch2 ch3 ...)   (lb & mv)    *
  19. ;*      (string-append ...), (char-whitespace c), (char-alphabetic? c)    *
  20. ;*      (char-numeric? c), (char-upper-case? c), (char-lower-case? c)     *
  21. ;*                                    *
  22. ;*                    ``In nomine omnipotentii dei''    *
  23. ;************************************************************************
  24.  
  25. ; The operations defined here are those proposed by Chris Hanson on
  26. ;  14 Jan 1985 and in a revision on 20 Mar 85.
  27.  
  28. ; ------------------- Basic Character Operations --------------------
  29.  
  30. ; CHAR?             PCS primitive (opcode)
  31. ; CHAR=?            PCS primitive (opcode)
  32. ; CHAR-CI=?           PCS primitive (opcode)
  33. ; CHAR<?              PCS primitive (opcode)
  34. ; CHAR-CI<?           PCS primitive (opcode)
  35. ; CHAR-UPCASE          PCS primitive (opcode)
  36. ; CHAR-DOWNCASE         PCS primitive (opcode)
  37. ; CHAR->INTEGER         PCS primitive (opcode)
  38.  
  39. (define-integrable char<=?
  40.   (lambda (ch1 ch2)
  41.     (or (char<? ch1 ch2)
  42.         (char=? ch1 ch2))))
  43.  
  44. (define-integrable char>=?
  45.   (lambda (ch1 ch2)
  46.     (not (char<? ch1 ch2))))
  47.  
  48. (define-integrable char>?
  49.   (lambda (ch1 ch2)
  50.     (not (or (char<? ch1 ch2)
  51.              (char=? ch1 ch2)))))
  52.  
  53. (define-integrable char-ci<=?
  54.   (lambda (ch1 ch2)
  55.     (or (char-ci<? ch1 ch2)
  56.         (char-ci=? ch1 ch2))))
  57.  
  58. (define-integrable char-ci>=?
  59.   (lambda (ch1 ch2)
  60.     (not (char-ci<? ch1 ch2))))
  61.  
  62. (define-integrable char-ci>?
  63.   (lambda (ch1 ch2)
  64.     (not (or (char-ci<? ch1 ch2)
  65.              (char-ci=? ch1 ch2)))))
  66.  
  67. (define-integrable (char-alphabetic? c)
  68.   (not (eq? (char-upcase c) (char-downcase c))))
  69.  
  70. (define-integrable (char-numeric? c)
  71.   (and (char<? c #\:)
  72.        (char>? c #\/)))
  73.  
  74. (define-integrable (char-upper-case? c)
  75.   (eq? c (char-upcase c)))
  76.  
  77. (define-integrable (char-lower-case? c)
  78.   (eq? c (char-downcase c)))
  79.  
  80. (define-integrable (char-whitespace? c)
  81.   (member c '(#\space #\tab #\newline #\page #\return)))
  82.  
  83. ; --------------------- Basic String Operations ---------------------
  84.  
  85. ; STRING?            PCS primitive (opcode)
  86. ; STRING-LENGTH             PCS primitive (opcode)
  87. ; STRING-REF            PCS primitive (opcode)
  88. ; STRING-SET!              PCS primitive (opcode)
  89. ; STRING->SYMBOL        PCS primitive (opcode)
  90. ; STRING->UNINTERNED-SYMBOL    PCS primitive (opcode)
  91. ; SYMBOL->STRING        PCS primitive (opcode)
  92.  
  93.  
  94. ; ----------------------- Standard Operations -----------------------
  95.  
  96. ; MAKE-STRING              PCS primitive (opcode)
  97. ; STRING-FILL!             PCS primitive (opcode)
  98. ; SUBSTRING            PCS primitive (opcode)
  99.  
  100.  
  101. (define (string-null? string)                ; STRING-NULL?
  102.   (eqv? string ""))
  103.  
  104. (define (string-append . args)                ; STRING-APPEND
  105.   (define (str s) (if (null? s) "" s))
  106.   (define (sa a b c)
  107.     (%string-append a 0 (string-length a)
  108.             b
  109.                 c 0 (string-length c)))
  110.   (cond ((null? args) "")
  111.     ((null? (cdr args)) (str (car args)))
  112.     ((null? (cddr args)) (sa (car args) '() (cadr args)))
  113.     (else (sa (car args) (cadr args) (apply string-append (cddr args))))))
  114.  
  115.  
  116. (define string-copy                    ; STRING-COPY
  117.   (lambda (string)
  118.     (%string-append string 0 (string-length string)
  119.             '()
  120.             "" 0 0)))
  121.  
  122.  
  123. (define string->list                    ; STRING->LIST
  124.   (lambda (string)
  125.     (do ((string string
  126.          string)
  127.      (index  0
  128.          (add1 index))
  129.      (end     (string-length string)
  130.          end)
  131.      (result '()
  132.          (cons (string-ref string index) result)))
  133.     ((= index end)
  134.      (%reverse! result)))))
  135.  
  136.  
  137. (define (list->string chars)                ; LIST->STRING
  138.   (do ((chars  chars
  139.            (cdr chars))
  140.        (index  0
  141.            (add1 index))
  142.        (result (make-string (length chars) '())
  143.            result))
  144.       ((null? chars) result)
  145.     (string-set! result index (car chars))))
  146. (define (string . l) (list->string l))
  147.  
  148. ;; ------------------------ Motion Primitives ------------------------
  149.  
  150.  
  151. (define (substring-fill! string start end char)        ; SUBSTRING-FILL!
  152.   (when (< start end)
  153.     (string-set! string start char)
  154.     (substring-fill! string (1+ start) end char)))
  155.  
  156.  
  157. (define                            ; SUBSTRING-MOVE-LEFT!
  158.   (substring-move-left! string1 start1 end1 string2 start2)
  159.   (when (< start1 end1)
  160.     (string-set! string2 start2
  161.              (string-ref string1 start1))
  162.     (substring-move-left!
  163.         string1 (1+ start1) end1 string2 (1+ start2))))
  164.  
  165.  
  166. (define substring-move-right!               ; SUBSTRING-MOVE-RIGHT!
  167.   (lambda (string1 start1 end1 string2 start2)
  168.     (letrec ((loop
  169.            (lambda (count1 count2)
  170.          (when (<= start1 count1)
  171.                (string-set! string2 count2
  172.                     (string-ref string1 count1))
  173.                (loop (-1+ count1) (-1+ count2)))))
  174.           (end2 (+ start2 (- end1 start1)))
  175.           )
  176.        (loop (-1+ end1) (-1+ end2)))))
  177.  
  178.  
  179. ;; ---------------------- Comparison Primitives ----------------------
  180.  
  181.  
  182. (define string=?                    ; STRING=?
  183.   (lambda (s1 s2)
  184.     (and (string? s1)(string? s2)(eqv? s1 s2))))
  185.  
  186.  
  187. (define string<?                    ; STRING<?
  188.   (lambda (s1 s2)
  189.     (let loop ((s1 s1)
  190.            (s2 s2)
  191.            (i1 0)
  192.            (i2 0)
  193.            (e1 (string-length s1))
  194.            (e2 (string-length s2)))
  195.      (cond ((= i1 e1) (< e1 e2))
  196.            ((= i2 e2) #F)
  197.            (else
  198.         (let ((c1 (string-ref s1 i1))
  199.               (c2 (string-ref s2 i2)))
  200.           (if (char=? c1 c2)
  201.               (loop s1 s2 (add1 i1)(add1 i2) e1 e2)
  202.               (char<? c1 c2))))))))
  203.  
  204.  
  205. (define string<=?                       ; STRING<=?
  206.   (lambda (s1 s2)
  207.     (let loop ((s1 s1)
  208.            (s2 s2)
  209.            (i1 0)
  210.            (i2 0)
  211.            (e1 (string-length s1))
  212.            (e2 (string-length s2)))
  213.      (cond ((= i1 e1) (<= e1 e2))
  214.            ((= i2 e2) #F)
  215.            (else
  216.         (let ((c1 (string-ref s1 i1))
  217.               (c2 (string-ref s2 i2)))
  218.           (if (char=? c1 c2)
  219.               (loop s1 s2 (add1 i1)(add1 i2) e1 e2)
  220.               (char<? c1 c2))))))))
  221.  
  222.  
  223. (define string>=?                       ; STRING>=?
  224.   (lambda (s1 s2)
  225.     (not (string<? s1 s2))))
  226.  
  227.  
  228. (define string>?                       ; STRING>?
  229.   (lambda (s1 s2)
  230.     (not (string<=? s1 s2))))
  231.  
  232.  
  233. (define substring=?)                    ; SUBSTRING=?
  234. (define substring-ci=?)                    ; SUBSTRING-CI=?
  235.  
  236. (letrec
  237.   ((make-substring=
  238.     (lambda (char-test)
  239.       (lambda (string1 start1 end1 string2 start2 end2)
  240.     (define (loop index1 index2)
  241.       (or (= index1 end1)
  242.           (and (char-test (string-ref string1 index1)
  243.                   (string-ref string2 index2))
  244.            (loop (1+ index1) (1+ index2)))))
  245.     (and (string? string1)
  246.          (string? string2)
  247.          (= (- end1 start1) (- end2 start2))
  248.          (loop start1 start2))))))
  249.   (begin
  250.     (set! substring=?                    ; SUBSTRING=?
  251.       (make-substring= (lambda (a b)(char=? a b))))
  252.     (set! substring-ci=?                ; SUBSTRING-CI=?
  253.       (make-substring= (lambda (a b)(char-ci=? a b))))))
  254.  
  255.  
  256. (define substring<?)                    ; SUBSTRING<?
  257. (define substring-ci<?)                    ; SUBSTRING-CI<?
  258.  
  259. (letrec
  260.  ((make-substring<
  261.     (lambda (char=test char<test)
  262.       (lambda (string1 start1 end1 string2 start2 end2)
  263.     (letrec ((loop
  264.           (lambda (index1 index2)
  265.             (cond ((or (= index1 end1)
  266.                    (= index2 end2))
  267.                (< (- end1 start1)
  268.                   (- end2 start2)))
  269.               ((char=test (string-ref string1 index1)
  270.                       (string-ref string2 index2))
  271.                (loop (1+ index1) (1+ index2)))
  272.               (else
  273.                (char<test (string-ref string1 index1)
  274.                       (string-ref string2 index2)))))))
  275.         (and (string? string1)
  276.              (string? string2)
  277.              (loop start1 start2)))))))
  278.  (begin
  279.    (set! substring<?                    ; SUBSTRING<?
  280.      (make-substring<
  281.             (lambda (a b)(char=? a b))
  282.         (lambda (a b)(char<? a b))))
  283.    (set! substring-ci<?                    ; SUBSTRING-CI<?
  284.      (make-substring<
  285.             (lambda (a b)(char-ci=? a b))
  286.         (lambda (a b)(char-ci<? a b))))))
  287.  
  288.  
  289. (define string-ci=?)                    ; STRING-CI=?
  290. (define string-ci<?)                    ; STRING-CI<?
  291.  
  292. (letrec
  293.   ((string-comparison
  294.     (lambda (substring-comparison)
  295.       (lambda (string1 string2)
  296.     (substring-comparison string1 0 (string-length string1)
  297.                   string2 0 (string-length string2))))))
  298.   (begin
  299.     (set! string-ci=?                    ; STRING-CI=?
  300.       (string-comparison substring-ci=?))
  301.     (set! string-ci<?                    ; STRING-CI<?
  302.       (string-comparison substring-ci<?))))
  303.  
  304. ;; ---------------------- Search Primitives ----------------------
  305.  
  306.  
  307. (define-integrable (substring-find-next-string str start end match)
  308.   (%str-str str start end match #f #t))
  309.  
  310. (define-integrable (substring-find-next-string-ci str start end match)
  311.   (%str-str str start end match #f #f))
  312.  
  313. (define-integrable (substring-find-previous-string str start end match)
  314.   (%str-str str start end match #t #t))
  315.  
  316. (define-integrable (substring-find-previous-string-ci str start end match)
  317.   (%str-str str start end match #t #f))
  318.